;;###########################################################################
;; dataobj3.lsp
;; Copyright (c) 1991-2002 by Forrest W. Young
;; This file contains methods for 
;; selecting  variables and observations, 
;; subsetting variables and observations
;; merging    variables and observations,
;; and
;; functions to calculate simple univariate statistics,
;; and table data methods (used by ANOVA)
;;###########################################################################

(defmeth mv-data-object-proto :active-variable-categories ()
  (mapcar #'(lambda (catvar)
              (remove-duplicates (send self :variable catvar) :test #'equal))
          (send self :active-variables '(category)))   )

(defmeth mv-data-object-proto :all-categories-of-all-active-category-variables ()
  (let* ((catvars (send self :active-variables '(category)))
         (all-cats))
    (mapcar #'(lambda (catvar)
                (setf cats (list (remove-duplicates 
                                  (send self :variable catvar) 
                                  :test #'equal)))
                (mapcar #'(lambda (cat)
                      	     (setf all-cats 		
                           	      (append all-cats
                                   	      (list (strcat cat "[" catvar "]")))))
                        (combine cats))
                )
            catvars)
    all-cats))

(defmeth mv-data-object-proto :select-variables (var-name-list)
"Args: VAR-NAME-LIST
Selects the variables in VAR-NAME-LIST from the list of variables.  Displays
the selection in the variable window when it is open."
  (if (not (eq current-data self)) (setcd self));fwy4.25
  (let* ((w (send *vista* :var-window-object))
         (var-num-list ($position var-name-list (send self :variables)))
         (states (repeat 'NORMAL (send self :nvar)))
         )
    (cond 
      (w (send w :selection var-num-list)
         (send self :var-states 
               (send w :point-state (iseq (send w :num-points)))))
      (t (setf (select states var-num-list)
                     (repeat 'SELECTED (length var-num-list)))
         (send self :var-states states)))))

(defmeth mv-data-object-proto :select-observations (obs-label-list)
"Args: OBS-LABEL-LIST
Selects the observations in OBS-LABEL-LIST from the list of observation labels.  Displays the selection in the observation window when it is open."
  (if (not (eq current-data self)) (setcd self));fwy4.25
  (let* ((w (send *vista* :obs-window-object))
         (obs-num-list ($position obs-label-list (send self :labels)))
         (states (repeat 'NORMAL (send self :nobs)))
         )
    (cond 
      (w (send w :selection obs-num-list)
         (send self :obs-states 
               (send w :point-state (iseq (send w :num-points)))))
      (t (setf (select states obs-num-list)
                     (repeat 'SELECTED (length obs-num-list)))
         (send self :obs-states states)))))


(defmeth mv-data-object-proto :var-states (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the selection states of the variables in the data object. Also sets :array-needs-computing to t, and changes menu states, when states change. The states mimic point selection states (normal, selected, invisible)." 
  (when set 
        (setf (slot-value 'var-states) list)
        (send self :set-menu-system)
        (send self :array-needs-updating t))
  (slot-value 'var-states))

(defmeth mv-data-object-proto :obs-states (&optional (list nil set))
"Message args: (&optional list)
 Sets or retrieves the selection states of the observations in the data object.  Also sets :array-needs-computing to t when states change. The states mimic point selection states (normal, selected, invisible)." 
  (when set 
        (setf (slot-value 'obs-states) list)
        (send self :array-needs-updating t))
  (slot-value 'obs-states))

(defmeth mv-data-object-proto :variable (name &optional values)
"Message args: (variable-name &optional values)
With no optional argument, returns a vector of values for variable-name, or nil if variable-name is not in the data object. With optional argument, places new values into data when variable exists in object."
    (let* ((var-names (send self :variables))
           (which (which ($= name var-names)));$= 
           (mat (send self :data-matrix))
           (n (first (array-dimensions mat))))
      (cond
        (values
         (setf mat (send self :data-matrix))
         (setf n (first (array-dimensions mat)))
         (when (not (= n (length values)))
               (fatal-message "Wrong number of values in value list"))
         (setf (select mat (iseq n) which) (matrix (list n 1) values))
         (send self :data (combine mat)))
        (t
         (if which
             (coerce (select (select (column-list (send self :data-matrix)) which) 0) 'list)
             (fatal-message (format nil "No variable named ~a" name)))))))

(defmeth mv-data-object-proto :active-variable (ok-types name)
"Message args: (ok-types variable-name)
Returns a vector of active values for variable-name, or nil if variable-name is not
an active variable in the data object."
    (let* ((var-names (send self :active-variables ok-types))
           (which (which ($= name var-names)));$= 
          )
      (if which
          (coerce (select (select 
            (column-list (send self :active-data-matrix ok-types)) which) 0) 'list)
          (fatal-message (format nil "No active variable named ~a" name)))))

(defmeth mv-data-object-proto :active-variables (ok-types)
"Message args: (ok-types)
Reports the names of the ok-types variables which are active.  
An active variable is one which is selected in the var-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, numeric, ordinal, category, label."
  (select (send self :variables) 
          (send self :current-variables ok-types)))


(defmeth mv-data-object-proto :active-types (ok-types)
"Message args: (ok-types)
Reports the types of the ok-types variables which are active.  
An active variable is one which is selected in the var-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, numeric, ordinal, category, label."
  (select (send self :types) 
          (send self :current-variables ok-types)))

(defmeth mv-data-object-proto :active-data-matrix (ok-types)
"Message args: (ok-types)
Reports, for ok-types variables which are active, the data in matrix form.
An active variable is one which is selected in the var-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, numeric, ordinal, category, label."
  (select (send self :data-matrix) (send self :current-labels)
          (send self :current-variables ok-types)))

(defmeth mv-data-object-proto :active-data (ok-types)
"Message args: (ok-types)
Reports, for ok-types variables which are active, the data in list form.
An active variable is one which is selected in the var-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, numeric, ordinal, category, label."
  (if (send self :ways) 
      (send self :data) ; for table data
      (combine (send self :active-data-matrix ok-types)) ; for mv data
      ))

(defmeth mv-data-object-proto :data-matrix ()
"Message args: none
Returns the data as a matrix."
  (let* ((n (send self :nvar))
         (m (send self :nobs)))
         (matrix (list m n) (send self :data))))


(defmeth mv-data-object-proto :active-nvar (ok-types)
"Message args: (ok-types)
Reports the number of the ok-types variables that are active.  
An active variable is one which is selected in the var-window, or if none 
selected, which is visible in the window.  Ok-types must be one of the 
following strings: all, numeric, ordinal, category, label."
  (length (send self :current-variables ok-types)))

(defmeth mv-data-object-proto :active-nobs ()
"Message args: none
Reports the number of active observations. An active observation is one which is selected in the var-window, or if none selected, which is visible in the window when it is displayed."
  (length (send self :current-labels)))

(defmeth mv-data-object-proto :icon-objid ()
     (select (send *workmap* :icon-list) 
             (1- (send self :icon-number))))





(defmeth mv-data-object-proto :merge-variables (&optional name)
"Method Args: (&optional name)
Horizontally merges active variables of two data objects which have the same number of observations. The current and the previous data object are merged. The new data object is named NAME (a string) if specified, otherwise a dialog is presented for name. Returns object identification of the new data object."
  (if (not (eq current-object self)) (setcd self))
  (let ((object nil)
        (prev-data previous-data)
        (prev-data-icon (send previous-data :icon-number))
        (menu-name nil)
        )
    (cond 
      ((/= (send self :active-nobs) (send previous-data :active-nobs))
           (error-message "Data Objects cannot be merged because they do not have the same number of observations."))
      (t
       (if name
           (setf menu-name name)
           (setf menu-name 
                 (get-string-dialog "Please Name the Created Data Object:"
                                    :initial "Unnamed")))
       (cond 
         (menu-name
          (setf object
               (data menu-name
                     :created (send *desktop* :selected-icon)  
                     :data (combine (bind-columns
                           (send previous-data :active-data-matrix '(all)) 
                           (send self  :active-data-matrix '(all))))
                     :variables (concatenate 'list
                           (send previous-data :active-variables '(all))
                           (send self  :active-variables '(all)))
                     :types (concatenate 'list
                           (send previous-data :active-types '(all))
                           (send self  :active-types '(all)))
                     :labels (send self :active-labels)))
          (send object :title 
                (concatenate 'string "Merger of " (send prev-data :title)
                             " with " (send self :title)))
          (send *desktop* :connect-icons 
                (- prev-data-icon 1)
                (- (send *desktop* :num-icons) 1) :new t)
          (send object :dob-parents 
                (add-element-to-list (send object :dob-parents) prev-data))
          (send prev-data :dob-children
                (add-element-to-list (send prev-data :dob-children) object))
          ))))
       object))

(defmeth mv-data-object-proto :merge-observations (&optional name)
"Method Args: (&optional name)
Vertically merges active observations of two data objects which have the same number of variables. The current and the previous data object are merged. The new data object is named NAME (a string) if specified, otherwise a dialog is presented for name. Returns object identification of the new data object."
  (if (not (eq current-object self)) (setcd self))
  (let ((object nil)
        (prev-data previous-data)
        (prev-data-icon (send previous-data :icon-number))
        (menu-name nil)
        )
    (cond 
      ((/= (send self :active-nvar '(all)) 
           (send previous-data :active-nvar '(all)))
           (error-message "Data Objects cannot be merged because they do not have the same number of active variables."))
      (t
       (if name
           (setf menu-name name)
           (setf menu-name 
                 (get-string-dialog "Please Name the Created Data Object:"
                                    :initial "Unnamed")))
       (cond 
         (menu-name
          (setf object
               (data menu-name
                     :created (send *desktop* :selected-icon)  
                     :data (combine (bind-rows
                           (send previous-data :active-data-matrix '(all)) 
                           (send self  :active-data-matrix '(all))))
                     :variables (send self :active-variables '(all))
                     :types     (send self :active-types     '(all))
                     :labels (concatenate 'list
                             (send previous-data :active-labels)
                             (send self :active-labels))))
          (send object :title 
                (concatenate 'string "Merger of " (send previous-data :title)
                             " with " (send self :title)))
          (send *desktop* :connect-icons 
                (- prev-data-icon 1)
                (- (send *desktop* :num-icons) 1) :new t)
          (send object :dob-parents 
                (add-element-to-list (send object :dob-parents) prev-data))
          (send prev-data :dob-children
                (add-element-to-list (send prev-data :dob-children) object))
          ))))
       object))

(defmeth mv-data-object-proto :current-labels ()
"Method Args: none
Returns a list of indices of all the observations. Old method replaced by PV."
  (let* ((nobs (send self :nobs))
         )
    (iseq nobs)))


(defmeth mv-data-object-proto :current-variables (ok-types)
"Method Args: (oktypes) 
Takes a list of variable types and returns a list of indices
of the variables of those types which are also active.  Active means they
are (or were when the window was closed) visible in the variable window 
(if any variables are selected, visible AND selected). Oktypes can be Label, Freq 
Category, Ordinal and Numeric, or All (which means select all types)."
  (let* ((nvar (send self :nvar))
         (states (send self :var-states))
         (selected-variables 
          (which (mapcar #'equal (repeat 'SELECTED nvar) states)))
         (types  (send self :types))
         (category-variables ())
         (label-variables ())
         (ordinal-variables ())
         (numeric-variables ())
         (freq-variables ())
         )
    (setf types (mapcar #'string-downcase types))
    (if (member 'Category ok-types) 
        (setf category-variables 
         (which (mapcar #'equal (repeat '"category" nvar) types))))
    (if (member 'label ok-types) 
        (setf label-variables 
         (which (mapcar #'equal (repeat '"label"    nvar) types))))
    (if (member 'ordinal ok-types) 
        (setf ordinal-variables 
         (which (mapcar #'equal (repeat '"ordinal"  nvar) types))))
    (if (member 'numeric ok-types) 
        (setf numeric-variables 
         (which (mapcar #'equal (repeat '"numeric"  nvar) types))))
    (if (member 'numeric ok-types) 
        (setf freq-variables 
         (which (mapcar #'equal (repeat '"freq"  nvar) types))))
    (if (member 'all ok-types)
        (setf numeric-variables (iseq nvar)))
    (if (equal selected-variables nil) 
       (setf selected-variables
             (which (mapcar #'not (mapcar #'equal
                                          (repeat 'INVISIBLE nvar) states)))))
    (setf selected-variables 
          (intersection selected-variables 
                        (union category-variables 
                               (union freq-variables
                                      (union label-variables 
                                             (union ordinal-variables 
                                                    numeric-variables))))))
    (if selected-variables (sort-data selected-variables)
        nil)))

  
(defmeth mv-data-object-proto :active-data-vectors (ok-types) 
  (column-list 
   (if (equal ok-types '(all)) 
       (send self :data-matrix) 
       (select (send self :data-matrix) 
               (send self :current-labels) 
               (send self :current-variables ok-types))))) 

(defmeth mv-data-object-proto :active-data-lists (ok-types) 
  (mapcar #'(lambda (vector) 
              (coerce vector 'list)) 
          (column-list 
           (if (equal ok-types '(all)) 
               (send self :data-matrix) 
               (select (send self :data-matrix) 
                       (send self :current-labels) 
                       (send self :current-variables ok-types)))))) 




;;---------------------------------------------------------------------------
;;define methods for reporting simple univariate statistics
;;---------------------------------------------------------------------------

(defmeth mv-data-object-proto :means ()
"Args: none
Reports the means of the active numeric variables."
  (mapcar #'mean
          (column-list (send self :active-data-matrix '(numeric)))))

(defmeth mv-data-object-proto :medians ()
"Args: none
Reports the medians of the active numeric and ordinal variables."
  (mapcar #'median
          (column-list (send self :active-data-matrix '(numeric ordinal)))))

(defmeth mv-data-object-proto :standard-deviations ()
"Args: none
Reports the standard deviations of the active numeric variables."
  (mapcar #'standard-deviation 
          (column-list (send self :active-data-matrix '(numeric)))))

(defmeth mv-data-object-proto :variances ()
"Args: none
Reports the variances of the active numeric variables."
  (^ (send self :standard-deviations) 2))

(defmeth mv-data-object-proto :minimums ()
"Args: none
Reports the minimums of the active numeric and ordinal variables."
  (mapcar #'min
          (column-list (send self :active-data-matrix '(numeric ordinal)))))

(defmeth mv-data-object-proto :maximums ()
"Args: none
Reports the maximums of the active numeric and ordinal variables."
  (mapcar #'max
          (column-list (send self :active-data-matrix '(numeric ordinal)))))

(defmeth mv-data-object-proto :mid-ranges ()
"Args: none
Reports the mid-ranges of the active numeric and ordinal variables."
  (mapcar #'mid-range 
          (column-list (send self :active-data-matrix '(numeric ordinal)))))

(defmeth mv-data-object-proto :ranges ()
"Args: none
Reports the ranges of the active numeric variables."
  (mapcar #'range
          (column-list (send self :active-data-matrix '(numeric)))))
               
(defmeth mv-data-object-proto :interquartile-ranges ()

"Args: none
Reports the interquartile ranges of the active numeric and ordinal variables."
  (mapcar #'interquartile-range
          (column-list (send self :active-data-matrix '(numeric ordinal)))))

(defmeth mv-data-object-proto :skewnesses ()
"Args: none
Reports the skewnesses of the active numeric variables."
  (mapcar #'skewness
          (column-list (send self :active-data-matrix '(numeric)))))

(defmeth mv-data-object-proto :kurtoses ()
"Args: none
Reports the kurtoses of the active numeric variables."
  (mapcar #'kurtosis
          (column-list (send self :active-data-matrix '(numeric)))))

(defmeth mv-data-object-proto :covariance-matrix ()
"Args: none
Reports the covariance-matrix of the active numeric variables."
  (covariance-matrix (send self :active-data-matrix '(numeric))))



;;-------------------------------------------------------------------------
;; methods to convert mv to table data - 
;; not needed by data, but still needed by anova
;;-------------------------------------------------------------------------

(defmeth mv-data-object-proto :make-table-data 
                         (response-variable-name &optional menu-name)
;1 make new labels from category variables
  (let* ((cat-matrix (send self :active-data-matrix '(category)))
         (cat-variables  (send self :active-variables '(category)))
         (cell-labels (make-cell-labels cat-matrix cat-variables))
         (ungrouped-resp-var (send self :variable response-variable-name))
         (nobs (length ungrouped-resp-var))
;2 sort new labels into order and create data cells
         (urv-mat (send self :active-data-matrix '(all)))
         (sorted-labels-and-grouped-data 
          (sort-labels-and-group-data cell-labels urv-mat))
;3 create new table data object 
         (table nil))
    (when (not menu-name) 
          (setf menu-name (strcat "Table-" (send self :title))))
    (setf table (data menu-name
                      :created (send *desktop* :selected-icon)
                      :data (second sorted-labels-and-grouped-data)
                      :variables (list response-variable-name)
                      :ways cat-variables
                      :classes (third sorted-labels-and-grouped-data)))
    table))

(defun sort-labels-and-group-data (cell-labels ungrouped-data)
  (let* ((sorted-table (sort-and-permute-dob 
                        ungrouped-data cell-labels cell-labels nil))
         (sorted-data (first sorted-table))
         (sorted-resp-var (combine (col sorted-data 0)))
         (sorted-labels (second sorted-table))
         (nobs (length sorted-labels))
         (nways (1- (second (size ungrouped-data)))) 
         (data-cell-list nil)
         (classes-list nil)
         (start 0)
         (finish nil)) 
    (dotimes (i (1- nobs))
       (when (not (equal (select sorted-labels i) 
                         (select sorted-labels (1+ i))))
             (setf finish i)
             (setf data-cell-list (add-element-to-list data-cell-list 
                          (select sorted-resp-var (iseq start finish))))
             (setf start (1+ i))))
    (setf data-cell-list (add-element-to-list data-cell-list 
                         (select sorted-resp-var (iseq start (1- nobs)))))
    (dotimes (i nways)
             (setf classes-list (add-element-to-list classes-list
                   (remove-duplicates (combine (col sorted-data (1+ i)))
                                  :test 'equal))))
    (list sorted-labels data-cell-list classes-list (first sorted-table))))



(defun make-cell-labels (cat-matrix cat-variables)
  (let ((row nil)
        (labels nil)
        (string "")
        (nobs (first (size cat-matrix)))
        (nvar (second (size cat-matrix)))
        (value nil)
        )
    (dotimes 
     (i nobs)
     ;(setf row (row (send current-data :active-data-matrix '(category)) i))
     (setf string "")
     (dotimes 
      (j nvar)
      (setf value (select cat-matrix i j))
      (when (numberp value) 
            (setf value (format nil "~s" (select cat-matrix i j))))
      (setf string (strcat string 
           (select cat-variables j) "[" value "] ")))
     (setf labels (add-element-to-list labels string)))
    labels)) 

(defmeth mv-data-object-proto :mv-to-table 
  (&key can-convert? make-only-intermediate-mv)
  (let ((nnumord (send self :active-nvar '(numeric ordinal)))
        (ncat (send self :active-nvar '(category)))
        (numpos (position "Numeric" (send self :active-types '(all)) 
                           :test #'equal))
        (ordpos (position "Ordinal" (send self :active-types '(all)) 
                          :test #'equal))
        (catpos (position "Category" (send self :active-types '(all)) 
                          :test #'equal))
        (result nil)
        )
    
    (cond
      (can-convert? 
       ;do this when only want to know if can be converted
       (if (or (> nnumord 1) (= ncat 0))
           (setf result nil)
           (setf result t)))
      ((or (> nnumord 1) (= ncat 0))
       (error-message "These data cannot be converted to table data."))
      (t
       ;If data convertable, create intermediate mv data 
       ;with numeric variable first, if necessary
       
       (when (not (< (min (adjoin numpos ordpos)) catpos))
             (data (strcat "Cls-" (send self :name))
                   :variables 
                   (combine 
                    (send self :active-variables '(numeric ordinal))
                    (send self :active-variables '(category)))
                   :labels (send self :labels)
                   :created (send *workmap* :selected-icon)
                   :types (combine 
                           (send self :active-types '(numeric ordinal))
                           (send self :active-types '(category)))
                   :data (combine 
                          (bind-columns (send self :active-data-matrix 
                                              '(numeric ordinal))
                                        (send self :active-data-matrix 
                                              '(category))))))
       ;now create the table data
       (when (not make-only-intermediate-mv)
             (when *guidemap*
                   (when (send *guidemap* :gui)
                         (error-message "Guidemaps do not work for classification data in this release. They are being turned off.")
                         (send *guidemap* :close)))
           (setf result 
                 (create-data (strcat "Tab-" (send self :name)) :table t)))
       ))
    result))

(defmeth mv-data-object-proto :can-make-table ()
"Message args: none
Returns t if data are convertable to table data, nil otherwise"
  (let* ((types (send self :active-types '(all)))
         (rest-types (remove-duplicates (rest types) :test 'equal))
         (numeric-var (first (send current-data :active-variables '(all)))))
    (and (equal (first   types) "Numeric")
         (= (length rest-types) 1)
         (equal (first rest-types) "Category"))))


(defmeth mv-data-object-proto :var-namelist (&key (show t))
"Method Args: none
Presents a namelist window containing a list of variable names."
  (let* ((var-window (name-list (send self :variables) 
                                :show nil
                              ; :go-away nil
                              ;  :location location13
                                :title "Variables"))
         )
   ; (send var-window :size 
   ;       (- (select namelist-size 0) msdos-fiddle)
   ;       (- (select namelist-size 1) msdos-fiddle))
    (when show (send var-window :show-window))
    (send var-window :fix-name-list)
   ; (send var-window :has-h-scroll (max (screen-size)))
   ; (send var-window :has-v-scroll (max (screen-size)))
    (send var-window :redraw)
    var-window))

(defmeth mv-data-object-proto :obs-namelist (&key (show t))
"Method Args: none
Presents a window containing a list of observation labels."
  (let ((obs-window (name-list (send self :active-labels)
                               :show nil
                             ;  :location location13
                               :title "Labels"))
        )
       
   ; (send obs-window :size 
   ;       (- (select namelist-size 0) msdos-fiddle) long-namelist-length)
    (when show (send obs-window :show-window))
    (send obs-window :fix-name-list)
    ;(send obs-window :has-h-scroll (max (screen-size)))
    ;(send obs-window :has-v-scroll (max (screen-size)))
    (send obs-window :redraw)
    obs-window))



(defmeth mv-data-object-proto :create-summary-data ()
  (let* ((n (length (send self :active-variables '(numeric))))
         (abort (when (= n 0) (fatal-message "There are no numeric variables.")))
         (moments 
           (bind-rows
            (combine "Mean" (send self :means) )
            (combine "StDev" (send self :standard-deviations) )
            (combine "Variance" (send self :variances) )
            (combine "Skewness"(send self :skewnesses))
            (combine "Kurtosis" (send self :kurtoses) )
            ))
         (fivnum
           (bind-columns 
            '("Q0-Minimum" "Q1-Quartile 1" "Q2-Median" "Q3-Quartile 3" "Q4-Maximum")  
            (transpose 
             (apply #'bind-rows 
                    (mapcar #'(lambda (var)(fivnum var))
                            (column-list (send self :active-data-matrix '(numeric)))
                            )))))
         (corre (bind-columns (repeat "Corr" n)
                             (correlation-matrix 
                              (send $ :active-data-matrix '(numeric)))))
         (covar (bind-columns (repeat "Covar" n)
                             (covariance-matrix 
                              (send $ :active-data-matrix '(numeric)))))
         (data      (combine (bind-rows moments fivnum corre covar)))
         (variables (combine "Type" (send $ :active-variables '(numeric))))
         (types     (combine "Category" (repeat "Numeric" n)))
         (labels    (combine (list 
                              "Mean" "Std-Deviation" "Variance" "Skew" "Kurtosis" 
                              "Q0-Min" "Q1" "Q2-Median" "Q3" "Q4-Max")
                             (mapcar #'(lambda (name) (strcat name "[Corr]")) (rest variables))
                             (mapcar #'(lambda (name) (strcat name "[Covar]")) (rest variables))
                             )))
    (data "Stats" :data data :types types :labels labels :variables variables
          :created (send *workmap* :selected-icon))))

(defmeth mv-data-object-proto :get-sob-extension (name)
"Args: name
Adds an extension number to name. The number is the count of the number of other objects with the same name."
  (cond 
    ((send self :full-name)
     (list (send self :full-name) (send self :name) (send self :extension)))
    (t (get-sob-extension name))))
